;;########################################################################
;; tourplot.lsp 
;; copyright (c) 1991-98 by Forrest W. Young
;; Contains code for the ViSta tourplot to create a guided tour object
;;########################################################################

;(require "vista")

(defmeth mv-data-object-proto :visualize-tour-plot ()
  (send *watcher* :write-text "Creating Guided Tour" :show t)
  (let* ((vars 
          (column-list (send current-data :active-data-matrix '(numeric))))
         (num-unique 
          (length (remove-duplicates (round (mapcar #'variance vars)))))
         (result nil)
         (data-matrix nil)
         (means nil)
         (pt-labs (send current-data :active-labels))
         (var-labs (send current-data :active-variables '(numeric))))
    (when (not (= 1 num-unique))
          (setf data-matrix (send current-data :active-data-matrix '(numeric)))
          (setf means (mapcar #' (lambda (x) (mean x)) (column-list data-matrix)))
          (setf data-matrix (center data-matrix))
          (setf data-matrix (normalize data-matrix 1))
          (setf vars (column-list data-matrix))
          (visuals vars pt-labs var-labs nil :scale-type nil)
          )
    (when (= 1 num-unique)      
          (visuals vars pt-labs var-labs nil :scale-type nil)
           )
    ))

;;########################################################################
;;define guided tour constructor function
;;########################################################################


(defun tourplot
  (vars &key point-labels variable-labels (title "HD Touring Plot")
        (size '(320 320)) (location '(50 50)) (show t) )
  (let ((nvar (length vars))
        (nobs (length (first vars)))
        (variables vars))
    (if (< nvar 6) 
        (too-few)
        (let* ((nvar-used (min nvar 9))
               (var-indices (if (> nvar-used 6)
                                (combine '(0 1 4 2 3 5) (iseq 6 (- nvar-used 1)))
                                '(0 1 4 2 3 5)))
               (permuted-variables (select variables var-indices))
               (centered-permuted-variables 
                (mapcar #'(lambda (var) (- var (mean var))) permuted-variables))
               (permuted-variable-labels 
                (if variable-labels
                    (select variable-labels var-indices)
                    (mapcar #'(lambda (i) (format nil "Var~a" i)) (iseq nvar-used))))
               (point-labels 
                (if point-labels point-labels
                    (mapcar #'(lambda (i) (format nil "Obs~a" i)) (iseq nobs))))
               (tp (tour-plot centered-permuted-variables
                              :show show
                              :scale-type nil ;'centroid-variable
                              :title title
                              :size size
                              :location location
                              :point-labels point-labels
                              :variable-labels permuted-variable-labels))
               )
          (when tp
                (send tp :transformation nil)
                (send tp :tour-alg)
                (send tp :scale-type 'centroid-variable))
          tp))))


(defun tour-plot (data &rest args)
  (let* ((graph (apply #'send tour-proto :new (length data) args))
         (num-vars (send graph :num-variables))
         )
    (send graph :visuals-tour t)
    (send graph :min-degrees -1)
    (send graph :deg (list (send graph :min-degrees) 
                           (send graph :min-degrees) 0))
    (send graph :radians (mapcar #'radians (send graph :deg)))
    (send graph :add-points data)
    (send graph :margin 
          44 (+ 20 (send graph :text-descent)) 
           3 (+ 20 (send graph :text-descent)));36 18 0 18
    (send graph :tour-variables (iseq 6))
    (send graph :incremental-rotation
          (let ((deg (send graph :deg))
                )  
            (send graph :six-dim-rotate 
                  (select deg 0) (select deg 1) (select deg 2)
                            num-vars)
            ))
    ;(mapcar #'(lambda (dim) (send graph :scale dim 2))
    ;      (iseq (send graph :num-variables)))
    ;(send graph :scale (iseq num-vars) 2)
    (send graph :slot-value 'rotation-type 'yawing)
    (when (send *vista* :initial-spin)
          (send graph :tour t)
          (send graph :idle-on t))
    (send graph :switch-add-box)
    graph))

;;########################################################################
;; define guided tour prototype based on visuals guided tour algorithm
;;########################################################################

(defproto tour-proto 
  '(visuals-tour tour tour-variables min-degrees deg rok radians 
    touring? spinning? incremental-rotation model-p spreadplot) 
   () spin-proto)


(defmeth tour-proto :isnew (&rest args)
  (apply #'call-next-method args)
  (let ((topbar (first (send self :slot-value 'overlays))))
    (send topbar :remove-button ':new-x)
    (send topbar :remove-button ':new-y)
    (send topbar :remove-button ':new-z))
  (setf *knt* 0)
  (send self :add-overlay (send tour-control-overlay-proto :new))
  (send self  :mouse-mode 'selecting)
  (send self :set-variables-with-labels '(0 1 2 3 4 5)
        (select (send self :variable-labels) '(0 1 2 3 4 5)))
  )

(defmeth tour-proto :visuals-tour (&optional (arg nil set))
"Determines type of tour algorithm:  t for visuals tour, nil for screen tour."
  (if set (setf (slot-value 'visuals-tour) arg))
  (slot-value 'visuals-tour))

(defmeth tour-proto :tour (&optional (arg nil set))
"Determines type of do-idle action:  t for HDtour, nil for 3D spin."
  (if set (setf (slot-value 'tour) arg))
  (slot-value 'tour))

(defmeth tour-proto :touring? (&optional (arg nil set))
"Indicates whether plot is touring or not"
  (if set (setf (slot-value 'touring?) arg))
  (slot-value 'touring?))

(defmeth tour-proto :spinning? (&optional (arg nil set))
"Indicates whether plot is spinning or not"
  (if set (setf (slot-value 'spinning?) arg))
  (slot-value 'spinning?))

(defmeth tour-proto :tour-variables (&optional (arg nil set))
"A six element vector of the variable indices for 6D rotation."
  (if set (setf (slot-value 'tour-variables) arg))
  (slot-value 'tour-variables))

(defmeth tour-proto :min-degrees (&optional (arg nil set))
"Minimum rotation increment in degrees for tour algorithm."
  (if set (setf (slot-value 'min-degrees) arg))
  (slot-value 'min-degrees))
  
(defmeth tour-proto :deg (&optional (arg nil set))
"Current rotation increment of tour algorithm on each of three axes, in degrees."
  (if set (setf (slot-value 'deg) arg))
  (slot-value 'deg))

(defmeth tour-proto :rok (&optional (arg nil set))
"Used to reverse rotation direction for rocking capability."
  (if set (setf (slot-value 'rok) arg))
  (slot-value 'rok))

(defmeth tour-proto :radians (&optional (arg nil set))
"Current rotation increment of tour algorithm on each of three axes, in radians."
  (if set (setf (slot-value 'radians) arg))
  (slot-value 'radians))

(defmeth tour-proto :incremental-rotation (&optional (arg nil set))
"Current incremental rotation matrix.  Specifies one rotation step of the tour algorithm."
  (if set (setf (slot-value 'incremental-rotation) arg))
  (slot-value 'incremental-rotation))

(defmeth tour-proto :model-p (&optional (arg nil set))
"Model-p is t if model being visualized, nil if data being visualized."
  (if set (setf (slot-value 'model-p) arg))
  (slot-value 'model-p))

(defmeth tour-proto :spreadplot (&optional (arg nil set))
"Obj-ID of associated spreadplot."
  (if set (setf (slot-value 'spreadplot) arg))
  (slot-value 'spreadplot))

;;########################################################################
;;define touring methods for tour-proto (to be activated by buttons)
;;########################################################################

(defmeth tour-proto :initial-tour ()
  (send self :transformation 
        #2A((0.7983820360176944 -0.6002963125195654 -0.0472277644998414) 
            (0.5459659666649359  0.7547389025401102 -0.3637174071118568) 
            (0.2539828494364584  0.2646006919264610  0.9303113382218748))
        )
  (mapcar #'(lambda (i)
              (send self :scale i (* .5 (send self :scale i))))
          (iseq 6))
  (send self :radians (/ (send self :radians) 4))
  (setf *knt* 0)
  (send self :tour t)
  (send self :idle-on t)
  (send self :redraw))

(defmeth tour-proto :six-dim-rotate (a b c ndim)
  (let ((tv (send self :tour-variables))
        (i-mat (identity-matrix ndim)))
    (matmult (make-rotation (row i-mat (select tv 0)) 
                            (row i-mat (select tv 3)) (radians a))
             (make-rotation (row i-mat (select tv 1)) 
                            (row i-mat (select tv 4)) (radians b))
             (make-rotation (row i-mat (select tv 2)) 
                            (row i-mat (select tv 5)) (radians c))))) 
 
(defmeth tour-proto :do-idle ()
"Method for guided tour to perform one step in the tour while system is 
otherwise idle."

  (cond 
    ((send self :tour)
     (let* ((tv (send self :tour-variables))
            (trans (send self :transformation))
            (radians (send self :radians)))
       (setf *knt* (1+ *knt*))
       (when (and (not (send *vista* :initial-spin))
                  (= *knt* 360)) 
             (send self :stop-go) 
             (send self :redraw))
       (when (= 0 (mod *knt* 3600)) (send self :new-tour))
       (cond
         ((not (send self :visuals-tour))
          (send self :rotate-2 
                (select tv 0) (select tv 1) (* (select radians 0) .1) :draw nil)
           (send self :rotate-2 
                (select tv 0) (select tv 2) (* (select radians 1) .1) :draw nil)
           (send self :rotate-2 
                (select tv 1) (select tv 2) (* (select radians 0) .1) :draw nil)
          (send self :rotate-2 
                (select tv 0) (select tv 3) (select radians 0) :draw nil)
          (send self :rotate-2 
                (select tv 1) (select tv 4) (select radians 1) 
                :draw (if (equal (send self :tour) 2) nil t)))
;This is the original Visuals method.  It doesn't work right and the
;menu item to activate it is commented out of the code below.
         ( t
           (send self :rotate-2 
                (select tv 0) (select tv 1) (select radians 0) :draw nil)
           (send self :rotate-2 
                (select tv 0) (select tv 2) (select radians 0) :draw nil)
           (send self :rotate-2 
                (select tv 1) (select tv 2) (select radians 0) :draw nil)
           (if trans (send self :transformation 
                           (matmult trans (send self :incremental-rotation)))
               (send self :transformation 
                     (send self :incremental-rotation)))))
       (when (equal (send self :tour) 2) (call-next-method))))
    (t (call-next-method))))

(defmeth tour-proto :hd-rock ()
      "Method to rock the tour plot by reversing rotation direction."
      (let ((deg (send self :deg (- (send self :deg))))
            )
        (send self :rok (not (send self :rok)))
        (send self :radians (mapcar #'radians deg))
        (send self :incremental-rotation 
              (send self :six-dim-rotate 
                     (select deg 0) (select deg 1) (select deg 2)
                     (send self :num-variables)))))

(defmeth tour-proto :tour-alg ()
"Method for guided tour to toggle between the two available tour algorithms by toggeling value of visuals-tour.  When visuals-tour is true, the algorithm is the original visuals algorithm.  When visuals-tour is nil,  the algorithm is a new algorithm based on screen horizontal and vertical that is faster than the visuals algorithm.  Both are equivalent until 3D rotations (the pitch, roll and yaw buttons) are used."
  (send self :visuals-tour (not (send self :visuals-tour)))
  (send self :redraw)
  )

(defmeth tour-proto :tour-speed (axis dir)
"Method for guided tour to control tour speed on each tour dimension."
  (let* ((min-degrees (send self :min-degrees))
         (deg (send self :deg))
         (degnow (select deg axis))
         (rok (send self :rok))
         (change 1.025)
         )
    (if (= degnow 0)
        (if dir 
            (if rok (setf (select deg axis) min-degrees)
                (setf (select deg axis) (* -1 min-degrees)))))
    (if (/= degnow 0)
        (if dir (setf (select deg axis) (* (select deg axis) change)) 
            (setf (select deg axis) (/ (select deg axis) change))))
    (if (> (select deg axis) 360) (setf (select deg axis) 360))
    (if (<  min-degrees (select deg axis) (- min-degrees))
        (setf (select deg axis) 0))
    (send self :incremental-rotation 
          (send self :six-dim-rotate 
                (select deg 0) (select deg 1) (select deg 2)
                          (send self :num-variables)))
    (send self :radians (mapcar #'radians deg))
    (send self :deg deg)
  ))

(defmeth tour-proto :home ()
"Method to return the tour plot to its home orientation.  The method also stops rotation and resets rotation increments to their default values and directions."
  (let* ((min-degrees (send self :min-degrees))
         (deg (send self :deg))
         (point-state (send self :point-state (iseq (send self :num-points))))
         )
    (send self :idle-on nil)
    (send self :rok     nil)
    (send self :deg     (list min-degrees min-degrees min-degrees))
    (send self :radians (mapcar #'radians (send self :deg)))
    (send self :transformation nil)
    (when (send self :spreadplot);added april 2000
          (send target1 :transformation nil)
          (send target2 :transformation nil)
          (when (send self :model-p) 
                (send ingram1 :transformation nil)
                (send ingram2 :transformation nil)))
    (send tour-plot :point-state 
          (iseq (send tour-plot :num-points)) point-state)
    ))

(defmeth tour-proto :stop-go ()
"Method to stop or start guided tour."
  (let ((npts (send self :num-points))
        )
    (send self :idle-on (not (send self :idle-on)))
    (send self :point-state (iseq npts) (send self :point-state (iseq npts)))
    (setf *knt* 361)
    ))

(defmeth tour-proto :old-tour ()
"Method for guided tour to perform residualization."
  (let* ((nobs (send self :num-points))
         (nvar (send self :num-variables))
         (nvar-1 (- nvar 1))
         (transf (send self :transformation))
         (point-state (send self :point-state (iseq nobs)))
         (svd-struct nil)
         )
    (when transf
          (setf svd-struct 
               (sv-decomp (select transf (iseq nvar) (iseq 3 nvar-1))))
          (setf transf 
               (bind-rows 
                (select transf (iseq 3) (iseq nvar)) 
                (transpose (matmult (select svd-struct 0)
                                    (diagonal (select svd-struct 1))))))
          (send self :transformation transf)
          (when (send self :spreadplot)
                (send (second (send (send self :spreadplot) :plot-objs))
                      :transformation transf)
                (send (third (send (send self :spreadplot) :plot-objs))
                      :transformation transf))
          (when (send self :model-p) 
                (send ingram1 :transformation transf)
                (send ingram2 :transformation transf)))
    (send self :point-state (iseq nobs) point-state)
    ))

(defmeth tour-proto :new-tour ()
"Method for guided tour to perform residualization."
  (let* ((nobs (send self :num-points))
         (nvar (send self :num-variables))
         (nvar-1 (- nvar 1))
         (transf (send self :transformation))
         (point-state (send self :point-state (iseq nobs)))
         (tv (send self :tour-variables))
         (svd-struct nil)
         )
    (when transf
          (setf svd-struct 
               (sv-decomp (select transf (iseq nvar) (iseq 3 nvar-1))))
          (setf transf 
               (bind-rows 
                (select transf (iseq 3) (iseq nvar)) 
                (transpose (matmult (select svd-struct 0)
                                    (diagonal (select svd-struct 1))))))
          (send self :transformation transf)
          (when (send self :spreadplot)
                (send (second (send (send self :spreadplot) :plot-objs))
                      :transformation transf)
                (send (third (send (send self :spreadplot) :plot-objs))
                      :transformation transf))
          (when (send self :model-p) 
                (send ingram1 :transformation transf)
                (send ingram2 :transformation transf)))
    (send self :point-state (iseq nobs) point-state)
    ))


(defmeth tour-proto :make-menu-item (item)
  (if (symbolp item)
      (case item
        (tour-method (send menu-item-proto :new "Tour Method"
            :action #'(lambda () (send self :tour-alg))))
        (show-targets 
         (setf *show-targets-menu-item* 
               (send menu-item-proto :new "Show Targets"
                     :action #'(lambda () (send self :show-targets)))))
        (t (call-next-method item)))
      item))

(defmeth tour-proto :show-targets ()
  (let* ((splot (send self :spreadplot))
         (c-size (send (send splot :container) :size))
         )
    (setf c-size (repeat (max c-size) 2))
    (send *show-targets-menu-item* :mark 
          (not (send *show-targets-menu-item* :mark)))
    (send spreadplot :targets (send *show-targets-menu-item* :mark))
    (refresh-spreadplot)
    (apply #'send (send splot :container) :size c-size)
    (send (send splot :container) :resize)))


;;########################################################################
;;define overlay to contain buttons for tour-proto
;;########################################################################

(defproto tour-control-overlay-proto '() () spin-control-overlay-proto)

(defmeth tour-control-overlay-proto :isnew ()
  (call-next-method)
  (let ((gap (slot-value 'gap))
        (side (slot-value 'side))
        (ascent (slot-value 'ascent))
        )
    (send self :slot-value 'downs 
          (combine (send self :slot-value 'downs)
                   (list 
                    (+ (* 5 (+ gap side gap ascent gap))) ; Tour
                    (+ (* 6 (+ gap side gap ascent gap))) ; h speed -
                    (+ (* 6 (+ gap side gap ascent gap))) ; h speed +
                    (+ (* 7 (+ gap side gap ascent gap))) ; v speed -
                    (+ (* 7 (+ gap side gap ascent gap))) ; v speed +
                    (+ (* 8 (+ gap side gap ascent gap)))))) ;New
    ))

(defmeth tour-control-overlay-proto :redraw ()
  (let* ((downs (slot-value 'downs))
         (gap (slot-value 'gap))
         (side (slot-value 'side))
         (graph (send self :graph))
         (top-margin (second (send graph :margin)))
         (spin-downs (+ 17 top-margin (select (slot-value 'downs) 0)))
         (draw-color (send graph :draw-color))
         (ascent (slot-value 'ascent))
         (left-margin (slot-value 'left-margin))
         (wbd nil)
         )
    (setf downs (+ downs (- top-margin 12)))
    (if (and (send graph :use-color) (send *vista* :background-color)) 
        (send graph :draw-color 'toolbar-background)
        (send graph :draw-color 'white))
    (send graph :paint-rect 
          2 (select (+ downs (* 4 gap) side) 6)
          (- left-margin gap 1) (- (first (last downs)) (select downs 5)))
    (if (send *vista* :background-color)
        (send graph :draw-color draw-color)
        (send graph :draw-color 'black))
    (send graph :frame-rect 
          2 (select (+ downs (* 4 gap) side) 6)
          (- left-margin gap 1) (- (first (last downs)) (select downs 5)))

    (send self :draw-button (send graph :spinning?) (* 2 gap) ;not idel-on
          spin-downs side side)

    (send self :draw-button (send graph :touring?) (* 2 gap)  ;idle-on
          (select (+ downs (* 6 gap) side ascent) 6) side side) 
    (mapcar #'(lambda (x y pm) 
                (send self :draw-button nil x y side side wbd pm)) 
            (list (* 2 gap) (+ 3 (* 2 gap) side) 
                  (* 2 gap) (+ 3 (* 2 gap) side) (* 2 gap))
            (select (+ downs (* 6 gap) side ascent) (iseq 7 10))
            (list nil t nil t)
            ) 
    (send self :draw-button nil (* 2 gap)  
          (select (+ downs (* 6 gap) side ascent) 11) side side) 
    (mapcar #'(lambda (s x y) (send graph :draw-string s x y))
            '("Tour" "HSpd" "VSpd" "New")
            (repeat (* 2 gap) 4)
            (select (+ downs (* 5 gap) side ascent) (list 6 7 9 11)))
    ))

(defmeth tour-control-overlay-proto :do-click (x y m1 m2)
  (let* ((graph (slot-value 'graph))
         (left-margin (slot-value 'left-margin))
         (top-margin (second (send graph :margin)))
         (spin-downs (+ 17 top-margin (select (slot-value 'downs) 0)))
         (rock-downs (+ 17 top-margin (select (slot-value 'downs) 2)))
         (downs (select (slot-value 'downs) (iseq 6 11)))
         (gap (slot-value 'gap))
         (side (slot-value 'side))
         (top (select (+ downs (* 4 gap) side) 0))
         (text-base (+ 3 (slot-value 'text-base)))
         (box-top (+ 3 (slot-value 'box-top)))
         (big-small t)
         (ascent (slot-value 'ascent))
         (downs (+ downs (* 6 gap) side ascent))
         (nv (send graph :num-variables))
         (idling (send graph :idle-on))
         (i nil)
         (button-x nil)
         (pm nil)
         )
    (setf downs (+ downs (- top-margin 12)))
    (when (and (< (* 2 gap) x (+ (* 2 gap) side))
               (< spin-downs y (+ spin-downs side)))
          (when (send graph :tour)
                (send graph :tour nil)
                (send graph :spinning? t)
                (send graph :touring? nil)
                (send graph :idle-on nil))
          (send self :draw-button t (* 2 gap) spin-downs side side)
          (send self :draw-button nil (* 2 gap) (select downs 0) side side))
    (when (and (< (* 2 gap) x (+ (* 2 gap) side))
               (< rock-downs y (+ rock-downs side)))
          (send self :draw-button t (* 2 gap) rock-downs side side t)
          (send graph :hd-rock))
    (when (and (< x left-margin) (< top y))
       (when (< (* 2 gap) x (+ (* 2 gap) side))
             (setf button-x (* 2 gap))
             (setf pm nil)
             (cond
               ((< (first downs)  y (+ (first downs) side))
                (format t "~d~%"(list downs  gap side x y))
                (when (not (send graph :tour)) 
                      (send graph :tour t)
                      (send graph :spinning? nil)
                      (send graph :touring? t)
                      (send graph :idle-on nil)
                      (send self :draw-button nil (* 2 gap) spin-downs side side))
                (send graph :idle-on (not (send graph :idle-on)))
                (send self :draw-button 
                      (send graph :idle-on) button-x (select downs 0)
                      side side)
                
                )
               ((< (sixth downs)  y (+ (sixth downs) side))
                (send self :draw-button t button-x 
                      (sixth downs) side side t)
                (send graph :new-tour))
               ((< (second downs) y (+ (second downs) side)) (setf i 1))
               ((< (fourth downs) y (+ (fourth downs) side)) (setf i 3))))
          (when (< (+ (* 3 gap) side) x (+ (* 3 gap) (* 2 side)))
                (setf button-x (+ (* 3 gap) side))
                (setf pm t)
                (cond
                  ((< (third downs) y (+ (third downs) side)) (setf i 2))
                  ((< (fifth downs) y (+ (fifth downs) side)) (setf i 4))))
          (when i
                (send self :draw-button t button-x (select downs i) 
                      side side )
                (send graph :while-button-down
                      #'(lambda (x y)
                          (send graph :tour-speed (if (> i 2) 1 0) pm)
                          (send graph :do-idle)
                          ) nil)
                (send self :draw-button nil button-x (select downs i) 
                      side side nil pm))
          )))